COMMENT ⊗   VALID 00005 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(DEFPROP TRACE
C00004 00003	(DEFPROP %%TRACE1
C00006 00004	(DEFPROP TRACET
C00009 00005	(DEFPROP RESET
C00010 ENDMK
C⊗;
(DEFPROP TRACE
 (LAMBDA (%%L)
  (MAPCAR
   (FUNCTION (LAMBDA (%%FN)
	      (PROG (%%IND %%T1 %%G1 %%G2)
		    (COND ((NOT	(AND (SETQ %%T1
				      (GETL %%FN
					    (QUOTE (EXPR SUBR
							 FEXPR
							 FSUBR))))
				     (NOT (GET %%FN
					       (QUOTE %%TRACE)))))
			   (RETURN NIL)))
		    (PUTPROP %%FN
			     (CONS (SETQ %%G1 (INTERN (GENSYM)))
				   (SETQ %%G2 (INTERN (GENSYM))))
			     (QUOTE %%TRACE))
		    (SET %%G1 0)
		    (PUTPROP (QUOTE %%TRACE)
			     (CONS %%G1
				   (GET	(QUOTE %%TRACE)
					(QUOTE %%CNTRS)))
			     (QUOTE %%CNTRS))
		    (PUTPROP %%G2
			     (CADR %%T1)
			     (SETQ %%IND (CAR %%T1)))
		    (PUTPROP %%FN
			     (LIST (QUOTE LAMBDA)
				   (QUOTE (%%L%%))
				   (LIST (QUOTE %%TRACE1)
					 (LIST (QUOTE QUOTE) %%FN)
					 (QUOTE %%L%%)
					 (LIST (QUOTE QUOTE) %%G1)
					 (LIST (QUOTE QUOTE) %%G2)
					 (OR (EQ %%IND (QUOTE FEXPR))
					     (EQ %%IND
						 (QUOTE FSUBR)))))
			     (QUOTE FEXPR))
		    (OR	(EQ %%IND (QUOTE FEXPR))
			(REMPROP %%FN %%IND))
		    (RETURN %%FN))))
   %%L))
 FEXPR)


(DEFPROP %%TRACE1
 (LAMBDA (%%NAM %%ARGS %%CNTR %%FUN %%F)
  (PROG (%%V)
	(PRINT (LIST (QUOTE ENTERING)
		     (SET %%CNTR (ADD1 (EVAL %%CNTR)))
		     %%NAM))
	(OR %%F (SETQ %%ARGS (EVAL (CONS (QUOTE LIST) %%ARGS))))
	(COND ((EQUAL (CHRCT) (LINELENGTH NIL)) (TERPRI NIL)))
	(TERPRI (PRIN1 (CONS %%NAM %%ARGS)))
	(SETQ %%V (COND	(%%F (EVAL (CONS %%FUN %%ARGS)))
			(T (APPLY (QUOTE %%FUN) %%ARGS))))
	(PRINT (LIST (QUOTE LEAVING)
		     (ADD1 (SET %%CNTR (SUB1 (EVAL %%CNTR))))
		     %%NAM))
	(RETURN (TERPRI (PRIN1 (%%VAL (QUOTE %%V)))))))
 EXPR)

(DEFPROP %%VAL (LAMBDA (%%T1) (CDR (GET %%T1 (QUOTE VALUE)))) EXPR)

(DEFPROP UNTRACE
 (LAMBDA (%%L)
  (MAPCAR (FUNCTION (LAMBDA (%%FN)
		     (PROG (%%IND %%T1 %%T2)
			   (COND ((NOT (SETQ %%T2
					     (GET %%FN
						  (QUOTE %%TRACE))))
				  (RETURN NIL)))
			   (SETQ %%T1 (GETL (CDR %%T2)
					    (QUOTE (EXPR SUBR
							 FEXPR
							 FSUBR))))
			   (PUTPROP %%FN
				    (CADR %%T1)
				    (SETQ %%IND (CAR %%T1)))
			   (EVAL (LIST (QUOTE REMOB)
				       (CAR %%T2)
				       (CDR %%T2)))
			   (REMPROP %%FN (QUOTE %%TRACE))
			   (OR (EQUAL %%IND (QUOTE FEXPR))
			       (REMPROP %%FN (QUOTE FEXPR)))
			   (RETURN %%FN))))
	  %%L))
 FEXPR)


(DEFPROP TRACET
 (LAMBDA NIL
  (PROG NIL
	(PUTPROP (QUOTE %%SETQ)
		 (GET (QUOTE SETQ) (QUOTE FSUBR))
		 (QUOTE FSUBR))
	(PUTPROP (QUOTE %%SET)
		 (GET (QUOTE SET) (QUOTE SUBR))
		 (QUOTE SUBR))
	(DEFPROP SETQ
	 (LAMBDA (%%X1%%)
	  (PROG (%%V1%%)
		(%%SETQ %%V1%% (EVAL (CONS (QUOTE %%SETQ) %%X1%%)))
		(TERPRI	(PRINT (LIST (QUOTE SETQ)
				     (CAR %%X1%%)
				     (%%VAL (QUOTE %%V1%%)))))
		(RETURN (%%VAL (QUOTE %%V1%%)))))
	 FEXPR)
	(DEFPROP SET
	 (LAMBDA (%%X2%% %%V2%%)
		 (PROG NIL
		       (%%SET %%X2%% (%%VAL (QUOTE %%V2%%)))
		       (TERPRI (PRINT (LIST (QUOTE SET)
					    %%X2%%
					    (%%VAL (QUOTE %%V2%%)))))
		       (RETURN (%%VAL (QUOTE %%V2%%)))))
	 EXPR)))
 EXPR)

(DEFPROP UNTRACET
	 (LAMBDA NIL
		 (PROG NIL
		       (REMPROP (QUOTE SETQ) (QUOTE FEXPR))
		       (REMPROP (QUOTE SET) (QUOTE EXPR))))
	 EXPR)

(DEFPROP SLST
 (LAMBDA (%%L)
  (MAPCAR (FUNCTION (LAMBDA (%%X) (PUTPROP %%X T (QUOTE %%TRACET))))
	  %%L))
 FEXPR)

(DEFPROP UNSLST
 (LAMBDA (%%L)
  (MAPCAR (FUNCTION (LAMBDA (%%X) (REMPROP %%X (QUOTE %%TRACET))))
	  %%L))
 FEXPR)


(DEFPROP RESET
	 (LAMBDA NIL
		 (MAPCAR (FUNCTION (LAMBDA (%%CNTR) (SET %%CNTR 0)))
			 (GET (QUOTE %%TRACE) (QUOTE %%CNTRS))))
	 EXPR)

(MAPC (FUNCTION (LAMBDA (X) (REMPROP X (QUOTE MACRO))))
      (QUOTE (TRACE UNTRACE TRACET UNTRACET SLST UNSLST RESET)))